(defpackage :representation-mixin
  (:use :cl)
  (:nicknames :rm)
  (:export :representation-mixin
           :rep-collapsed-node
           :make-representation
           :turn-on-arrows
           :representation
           :show-rep-on-mistake
           :show-rep-on-hint
           :representation-visible-p
           :representation-enabled-p
           :highlight-rep-nodes-p))

(in-package :representation-mixin)

(defclass representation-mixin ()
  ((show-rep-on-mistake :initarg :show-rep-on-mistake :initform t :accessor show-rep-on-mistake)
   (show-rep-on-hint :initarg :show-rep-on-hint :initform t :accessor show-rep-on-hint)
   (show-arrows :initform nil :accessor show-arrows)
   (old-event-callback :initform nil :accessor old-event-callback)
   (representation :accessor representation)))

(defgeneric rep-collapsed-node (state)
  (:method-combination progn :most-specific-last)
  (:documentation "When a rep node is collapsed, call this."))

(defclass rep-motion-event (exp:event)
  ((enter :initform nil :initarg :enter :accessor enter)
   (leave :initform nil :initarg :leave :accessor leave)))

(exp:define-event-match rep-mouse-motion ((state representation-mixin)
                                          (event rep-motion-event))
  (let ((em (when (enter event) (d:id (enter event))))
        (lm (when (leave event) (d:id (leave event)))))
    (list :enter em :leave lm)))

(defclass rep-keypad-event (exp:event)
  ((keypad :initform nil :initarg :keypad :accessor keypad-event-keypad)
   (value :initform nil :initarg :value :accessor keypad-event-value)))

(exp:define-event-match rep-keypad-input ((state representation-mixin)
                                          (event rep-keypad-event)
                                          value)
  (if value-supplied
      (equal value (keypad-event-value event))
      (keypad-event-value event)))

(exp:define-state-match rep-keypad ((state representation-mixin))
  (let ((kp (find-rep-keypad state)))
    (when kp
      (d:id (kp:target kp)))))

(defun disable-event-callback (state)
  (setf (old-event-callback state) (d:event-callback (p:diagram state))
        (d:event-callback (p:diagram state)) nil))

(defun enable-event-callback (state)
  (setf (d:event-callback (p:diagram state)) (old-event-callback state)))

(defun representation-visible-p (state)
  (and (gwee:view-subviews (representation state)) t))

(defun representation-enabled-p (state)
  (not (d:event-callback (p:diagram state))))

(exp:define-state-match bt:fill-mode ((state representation-mixin))
  (and (not (representation-enabled-p state))
       (eql (p:mode state) :fill)))

(exp:define-state-match representation-mode ((state representation-mixin))
  (and (representation-enabled-p state)
       (eql (p:mode state) :fill)))

(defgeneric highlight-rep-nodes-p (state)
  (:documentation "The class inheriting representation-mixin must implement this method"))

(defmethod exp:state-dump append (exp (state representation-mixin))
  `(:show-rep-on-hint ,(show-rep-on-hint state)
    :show-rep-on-mistake ,(show-rep-on-mistake state)))

(defmethod exp:state-list-objects append (exp (state representation-mixin))
  (let ((keypad (find-if (lambda (v) (typep v 'kp:tiny-keypad))
                         (gwee:view-subviews (gwee:view-parent (representation state))))))
    (list :representation (when (gwee:view-subviews (representation state))
                            (bt:convert-tree state (d:root (first (gwee:view-subviews (representation state))))))
          :representation-keypad (when keypad
                                   (d:id (kp:target keypad))))))

(defmethod exp:state-list-actions append (exp (state representation-mixin))
  (when (representation-enabled-p state)
    (let ((kp (find-rep-keypad state)))
      (if kp
          `((representation-fill-node-action :node ,(d:id (kp:target kp)) :input :string)
            (representation-leave-action :node ,(d:id (kp:target kp))))
          (loop for i in (d:collect-on-tree (constantly t) (d:root (first (gwee:view-subviews (representation state))))
                                            :only-type 'd:input-argument)
             collect `(representation-enter-action :node ,(d:id i)))))))

(defun make-equation (root unknown-arg constant-arg)
  (labels ((a-or-q (node)
             (if (typep node 'd:input-argument)
                 (d:answer node)
                 (d:quantity node))))
    (let* ((copy (tree:dumb-copy root t))
           (selected (d:selected-nodes copy))
           (bottom (d:find-if-on-tree (lambda (b)
                                        (and (d:selected b)
                                             (null (d:quantity (d:box-left-arg b)))
                                             (null (d:quantity (d:box-right-arg b)))))
                                      copy
                                      :only-boxes t))
           (top (d:find-if-on-tree (lambda (b)
                                     (and (not (d:selected b))
                                          (d:parent-boxes b)
                                          (= (count-if (lambda (arg)
                                                         (and (d:selected (tree:parent arg))
                                                              (null (d:quantity arg))))
                                                       (tree:parents b))
                                             2)))
                                   root
                                   :only-boxes t)))
      (print `(make-eq ,copy))
      (assert top () "Can't find top box!")
      (loop for s in selected do
           (dolist (c (tree:children s))
             (when (d:quantity c)
               ;; FIXME: How to get them to draw in the right color?
               (let ((i (make-instance 'd:input-argument)))
                 (change-class c (if (numberp (d:quantity c))
                                     'd:number-input-argument
                                     'd:operator-input-argument)
                               :input-location :above
                               :foreground (d:foreground i)
                               :background (d:background i)))
               (setf (d:answer c) (d:quantity c)
                     (d:quantity c) nil
                     (tree:children c) nil))))
      (d:clear-selected copy)
      (setf (tree:parents bottom) nil)
      ;; clean out the top box so it just looks like an X box
      (dolist (b (d:collect-on-tree (lambda (b) (eql (d:id b) (d:id top)))
                                    bottom
                                    :only-boxes t))
        (setf (tree:children b) (list [a])))
      (let* ((times [m [i nil :input-location :above :answer (a-or-q unknown-arg)] [*] [a nil [m [a] :id (d:id top)]]])
             (plus [m [a nil times] [+] [i nil :input-location :above :answer (a-or-q constant-arg)]]))
        [m [a nil bottom] [a '=] [a nil plus]]))))

(defun simplify-answer (answer)
  (typecase answer
    (d:argument answer)
    (d:box answer)
    (list
     (cond
       ((and (eq (if (typep (first answer) 'd:argument)
                     (d:quantity (first answer))
                     answer)
                 '*)
             (find :empty answer))
        :empty)
       ((eq (third answer) :empty)
        (simplify-answer (second answer)))
       (t
        (let ((items (mapcar #'simplify-answer answer)))
          (if (equal items answer)
              items
              (simplify-answer items))))))
    (t answer)))

(defun highlight-rep-nodes (rep hint-tree)
  (labels ((collect (answer)
             (typecase answer
               (d:argument
                (when (or (find (d:quantity answer) '(- /))
                          (numberp (d:quantity answer)))
                  (list answer)))
               (d:box (list answer))
               (list
                (apply 'nconc (mapcar #'collect answer)))
               (t nil)))
           (highlight (node)
             (typecase node
               (d:box
                (mapc #'highlight (tree:children node)))
               (d:argument
                (setf (d:foreground node) (gwee:color 0 255 0)
                      (d:background node) (gwee:color 200 250 200))))))
      (print `(simp ,(simplify-answer hint-tree)))
      (d:funcall-on-tree (lambda (n)
                           (setf (d:foreground n) (gwee:gray 0))
                           (setf (d:background n) (gwee:gray 240)))
                         rep
                         :only-type 'd:argument)
      (loop for i in (collect (simplify-answer hint-tree))
         for nodes = (d:collect-on-tree (lambda (node)
                                          (and (eq (d:id node) (d:id i))
                                               (print `(begin))
                                               (or (print (not (typep node 'd:box)))
                                                   (print (> (length (tree:parents node)) 1))
                                                   (print (not (find '* (tree:children (tree:parent (tree:parent node)))
                                                                     :key 'd:quantity))))))
                                        rep)
         do (mapc #'highlight nodes))))

(defgeneric rep-callback (view event))

(defmethod rep-callback (view event)
  (print `(boom))
  t)

(defun update-rep-size (rep view diagram)
  (d:space-tree view)
  (let* ((dim (d:tree-rectangle (d:root view)))
         (expression-width (+ (geom:width dim) 40))
         (diagram-width (+ (gwee:view-width diagram) 4))
         (width (max expression-width diagram-width)))
    (setf (gwee:view-width view) (- width 40)
          (gwee:view-height view) (+ (geom:height dim) 20)
          (gwee:view-width rep) width
          (gwee:view-height rep) (gwee:view-height view)
          (gwee:view-right rep) (gwee:view-right (gwee:view-parent rep))
          (gwee:view-bottom rep) (- (gwee:view-bottom diagram) 15)
          (gwee:view-needs-update-p rep) t
          (gwee:view-needs-sync-p (gwee:view-parent rep)) t)
    (d:update-diagram-view view)))

(defun rep-kp-callback (state view kp s)
  (declare (ignore view))
  (exp:state-dispatch-event exp:*experiment* state
                            (make-instance 'rep-keypad-event :keypad kp :value s)))

(exp:define-action fill-node ((state representation-mixin)
                              (rep-keypad-input :var input-string)
                              (rep-keypad :var keypad-node))
  (let ((node (d:find-id-or-die (d:root (first (gwee:view-subviews (representation state))))
                                keypad-node)))
    (check-type node d:input-argument)
    (symbol-macrolet ((val (d:quantity node)))
      (exp:lg 'input :node keypad-node :value input-string)
      (case input-string
        (:backspace
         (when (plusp (length val))
           (setf val (subseq val 0 (1- (length val))))
           (when (string= val "")
             (setf val nil))))
        (t
         (setf val (concatenate 'string val input-string))))
      (update-rep-size (representation state)
                       (first (gwee:view-subviews (representation state)))
                       (p:diagram state)))))

(defun maybe-finish-rep (state view)
  (unless (d:find-if-on-tree (lambda (n)
                               (typep n 'd:input-argument))
                             (d:root view))
    (exp:lg 'representation-end)
    (enable-event-callback state)
    ;; filling in the rep is considered a stage
    (p::update-guided-state state :stage)
    (p:clear-message state :all)
    (when (p:guidedp state) (p:show-hint state))))

(defun rep-open-keypad-for (state view node)
  (let* ((input (make-instance 'kp:tiny-keypad :parent (gwee:view-parent (representation state)) :x 0 :y 0
                               :target node
                               :key-callback (lambda (kp s) (rep-kp-callback state view kp s))))
         (other (d:find-node-by-id (d:root (bt:last-state state)) (d:id node))))
    (d:clear-arrows (d:root (bt:last-state state)))
    (d:clear-highlights (d:root view))
    (when (and other (show-arrows state))
      (setf (d:arrow other) t))
    (d:update-diagram-view (bt:last-state state))
    (setf (d:highlighted node) t)
    (gwee:add-hook (gwee:leave-hook input) (lambda (kp x y s) (leave-input state view kp x y s)))
    (gwee:sync-views (gwee:view-parent (representation state)))
    (setf (gwee:view-needs-update-p (gwee:view-parent (representation state))) t)
    (setf (gwee:view-x input)
          (- (+ (gwee:view-x (representation state))
                (gwee:view-x view)
                (geom:x node))
             (u:half (- (gwee:view-width input) (geom:width node))))
          (gwee:view-y input)
          (- (+ (gwee:view-y (representation state))
                (gwee:view-y view)
                (geom:y node))
             (gwee:view-height input)
             (- (gwee:margin-bottom (slot-value input 'kp::default)))))))

(defun maybe-popup-new-keypad (state view)
  "After a node in the equation rep has been submitted, the equation
changes size, possibly putting an input box right below the mouse. In
such a case, pop up a new keypad."
  ;; we need to do this to make sure the rep has been resized
  (gwee:sync-views)
  (multiple-value-bind (x y) (gwee:get-mouse-state view)
    (let ((node (d:find-if-on-tree (lambda (n)
                                     (and (typep n 'd:input-argument)
                                          (geom:insidep n x y)))
                                   (d:root view))))
      (when node (rep-open-keypad-for state view node)))))

(defmethod rep-collapsed-node progn (state))

(defun collapse-node (state view node)
  (if (typep node 'd:input-argument)
      (if (and (d:valid-input-p node (d:quantity node))
               (string= (d:quantity node) (u:string2 (d:answer node))))
          (progn
            (p:clear-message state :error)
            (exp:lg 'collapse :value (d:quantity node) :node (d:id node))
            (o:collapse-input-argument node)
            (update-rep-size (representation state) view (p:diagram state))
            (rep-collapsed-node state)
            (maybe-popup-new-keypad state view)
            (maybe-finish-rep state view))
          (when (d:quantity node)
            (p:display-message state :error "~a is the wrong value." (d:quantity node))
            (exp:lg 'collapse-fail :reason :incorrect-value :value (d:quantity node)  :node (d:id node))))
      (exp:lg 'collapse-node-weirdness :node node :id (d:id node) :type (type-of node))))

(defun leave-input (state view kp x y s)
  (declare (ignore s))
  (setf x (gwee:top-to-view-x view x)
        y (gwee:top-to-view-y view y))
  (unless (geom:insidep (kp:target kp) x y)
    (exp:state-dispatch-event exp:*experiment* state
                              (make-instance 'rep-motion-event
                                             :leave (kp:target kp)))))

(defun delete-inputs (state)
  (gwee:delete-views-if (lambda (v) (typep v 'kp:tiny-keypad))
                        (gwee:view-parent (representation state))))

(defun find-rep-keypad (state)
  (find-if (lambda (v) (typep v 'kp:tiny-keypad))
           (gwee:view-subviews (gwee:view-parent (representation state)))))

(defmethod rep-callback (view (event e:motion-event))
  (exp:state-dispatch-event exp:*experiment* (exp:current-state exp:*experiment*)
                            (make-instance 'rep-motion-event
                                           :leave (e:leave event)
                                           :enter (e:enter event))))

(defun left-side-done-p (root)
  (not (d:find-if-on-tree (constantly t)
                          (d:box-left-arg root)
                          :only-type 'd:input-argument)))

(defun node-on-right-side-p (root node)
  (and (d:find-on-tree node (d:box-right-arg root)) t))

(exp:define-action rep-motion ((state representation-mixin)
                               (rep-mouse-motion :var motion))
  (when (getf motion :leave) (exp:lg 'leave :node (getf motion :leave)))
  (when (getf motion :enter) (exp:lg 'enter :node (getf motion :enter)))
  (let* ((old (find-rep-keypad state))
         (view (first (gwee:view-subviews (representation state))))
         (enter (when (getf motion :enter)
                  (d:find-id-or-die (d:root view) (getf motion :enter)))))
    (delete-inputs state)
    (when (and old
               (u:neq (kp:target old) enter))
      (setf (d:highlighted (kp:target old)) nil)
      (d:clear-arrows (d:root (bt:last-state state)))
      (d:update-diagram-view (bt:last-state state))
      (collapse-node state view (kp:target old)))
    (when (typep enter 'd:input-argument)
      (p:clear-message state :stage-advanced)
      (if (and (node-on-right-side-p (d:root view) enter)
               (not (left-side-done-p (d:root view))))
          (p:display-message state :error "Finish the left-hand side of the equation first.")
          (progn
            (rep-open-keypad-for state view enter))))))

(defun discover-unknown-and-constant-tiles (root)
  "Return the unknown and constant tiles as a values list. This only
works for the linearize operation."
  (let ((inputs (d:collect-on-tree (constantly t)
                                   root
                                   :only-type 'd:input-argument)))
    (cond
      ((> (length inputs) 2)
       (error "There are ~a input tiles! (expected 1 or 2)" (length inputs)))
      ((= (length inputs) 2)
       (values (second inputs) (first inputs)))
      ((= (length inputs) 1)
       (let* ((input (first inputs))
              (box (tree:parent input)))
         (ecase (d:quantity (d:box-operator-arg box))
           (+ (values
               (d:box-left-arg (tree:child (d:box-right-arg box)))
               input))
           (* (values
               input
               (d:box-left-arg (d:parent-box box)))))))
      ((zerop (length inputs))
       (error "There are no input tiles! (expected 1 or 2)")))))

(defun turn-on-arrows (state)
  (if (rm::show-arrows state)
      (exp:lg 'representation-arrows-already-on)
      (progn
        (exp:lg 'representation-show-arrows)
        (incf (p:num-hints state))
        (setf (rm::show-arrows state) t)
        (p:display-message state :hint "Green arrows will now help you fill in the blue tiles."))))


(defun make-representation (state)
  (unless (representation-visible-p state)
    (setf (gwee:view-subviews (representation state)) nil)
    (disable-event-callback state)
    (setf (show-arrows state) (eq (p:guidedp state) t))
    (d:clear-arrows (d:root (p:diagram state)))
    (let ((view (make-instance 'lv:linear-view
                               :parent (representation state)
                               :x :left :y :center
                               ;;:background (gwee:color 255 200 100)
                               :width 1 :height 1
                               :arg-margin 2
                               :arg-padding 5
                               :event-callback 'rep-callback
                               :compressed nil)))
      (gwee:add-hook (gwee:leave-hook view) (lambda (v x y s)
                                              (declare (ignore v))
                                              (let ((kp (find-rep-keypad state)))
                                                (when kp
                                                  (leave-input state view kp x y s)))))
      (multiple-value-bind (unknown constant) (discover-unknown-and-constant-tiles (d:root (p:diagram state)))
        (setf (d:root view) (make-equation (d:root (bt:last-state state)) unknown constant)))
      (exp:lg 'representation-start :tree (u:sharp-dot (d:root view)))
      (update-rep-size (representation state) view (p:diagram state))
      (p:clear-message state :all)
      (p:display-message state :hint
                         "We want you to rewrite the part of the tree that you are linearizing into the left side of an equation form to help you see how to do it"))))

;; (defmethod p:wrong-tile-value progn ((state representation-mixin) (node d:input-argument))
;;   (when (and (typep (p:transformation state)
;;                     'lt:linearize-transformation)
;;              (show-rep-on-mistake state)
;;              (not (representation-visible-p state)))
;;     (make-representation state)))

;; (defmethod p:show-hint-fill-input :around ((state representation-mixin) node)
;;   (when (and (show-rep-on-hint state)
;;              (not (representation-visible-p state)))
;;     (make-representation state)))

;; ;; Do this before because arg-fill-in-instructions has a side effect
;; ;; of clearing arrows. So let the main method decide if arrows should
;; ;; be displayed.
;; (defmethod p:show-hint-fill-input :before ((problem representation-mixin) tree)
;;   "Highlight nodes in the representation that are relevant to the hint."
;;   (let ((rep (first (gwee:view-subviews (representation problem)))))
;;     (when (and (highlight-rep-nodes-p problem)
;;                rep)
;;       (multiple-value-bind (arg hint) (guide::arg-fill-in-instructions tree)
;;         (declare (ignore arg))
;;         (when (typep hint lt::hint)
;;           (highlight-rep-nodes (d:root rep) (second hint))
;;           (d:update-diagram-view rep))))))

(defun clear-representation (state)
  (delete-inputs state)
  (when (d:root (bt:last-state state))
    (d:clear-arrows (d:root (bt:last-state state))))
  (d:update-diagram-view (bt:last-state state))
  (setf (gwee:view-subviews (representation state)) nil
        (gwee:view-width (representation state)) 0
        (gwee:view-height (representation state)) 0))

(defmethod p:post-navigate-clean-up progn ((state representation-mixin) how)
  (print `(rep nav ,(p:mode state) ,(representation-visible-p state)))
  (when (and (representation-visible-p state)
             (u:neq (p:mode state) :fill))
    (clear-representation state)))

(defmethod p:finish-fill-mode progn ((state representation-mixin))
  (clear-representation state))

(defmethod bt:wizard-step :around ((state representation-mixin))
  (print `(got here))
  (if (representation-enabled-p state)
      (let* ((view (first (gwee:view-subviews (representation state))))
             (tree (d:root view))
             (input (d:find-if-on-tree (lambda (n) (and (typep n 'd:input-argument)
                                                        (string/= (u:string2 (d:quantity n))
                                                                  (u:string2 (d:answer n)))))
                                       tree)))
        (cond
          (input
           (setf (d:quantity input) (u:string2 (d:answer input)))
           (collapse-node state view input))
          (t (p:display-message state :wizard "nothing to step in representation?"))))
      (call-next-method)))

(defmethod bt:wizard-undo :around ((state representation-mixin))
  (if (representation-enabled-p state)
      (progn
        (p:clear-message state :all)
        (enable-event-callback state)
        (clear-representation state)
        (p::update-guided-state state :stage))
      (call-next-method)))

(exp:define-action rep-hint ((state representation-mixin)
                             (exp:click :source :hint)
                             (representation-mode))
  (exp:lg 'hint :already-guided :representation))

;; (defmethod bt:hints-enabled progn ((state representation-mixin))
;;   (when (eq (p:mode state) :fill)
;;     (make-representation state)))
